home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / menus.tcl < prev    next >
Encoding:
Text File  |  1998-12-16  |  26.0 KB  |  933 lines  |  [TEXT/ALFA]
  1. # Menu creation procs
  2.     
  3. namespace eval menu {}
  4. namespace eval global {}
  5. namespace eval file {}
  6.  
  7. proc menu::buildBasic {} {
  8.     global winMenu HOME
  9.     # These are built on the fly
  10.     Menu -n File -p menu::generalProc {}
  11.     Menu -n Edit -p menu::generalProc {}
  12.     Menu -n Text -p menu::generalProc {}
  13.     Menu -n Search {}
  14.     Menu -n Utils {}
  15.     Menu -n Config {}
  16.     Menu -n $winMenu {}
  17.     
  18.     insertMenu "File"
  19.     insertMenu "Edit"
  20.     insertMenu "Text"
  21.     insertMenu "Search"
  22.     insertMenu "Utils"
  23.     insertMenu "Config"
  24.     insertMenu $winMenu
  25.     
  26.     if {![catch {glob [file join $HOME Help *]} files]} {
  27.     set men { "Alpha Manual" "Quick Start" "Alpha Commands" "Tcl Commands" \
  28.       "(-" "Readme" "Changes" \
  29.       "Extending Alpha" "Bug Reports and Debugging" "(-" }
  30.     foreach f $men {
  31.         if {$f != "(-" && ![file exists [file join ${HOME} Help $f]]} {
  32.         set men [lremove $men $f]
  33.         }
  34.     }
  35.     set ignore "" 
  36.     foreach f [lsort $files] {
  37.         set f [file tail $f]
  38.         if {[lsearch $men $f] < 0 && [lsearch $ignore $f] < 0} {
  39.         lappend men $f
  40.         }
  41.     }
  42.     regsub -all {\(-[ \t\r\n]+\(-} $men {\(-} men
  43.     foreach f $men {
  44.         addHelpMenu $f
  45.     }
  46.     }
  47.     
  48. }
  49.  
  50. proc menu::buildwinMenu {} {
  51.     global winMenu winNameToNum
  52.     set ma {
  53.     "//<Szoom"
  54.     "//<S<I<OsinglePage"
  55.     "<S/;chooseAWindow"
  56.     "/I<Biconify"
  57.     {Menu -n arrange -p menu::winTileProc {
  58.         "/Jvertically^1"
  59.         "/J<O<Ihorizontally^2"
  60.         "/J<B<OunequalVert^6"
  61.         "/J<B<I<OunequalHor^5"
  62.         "(-"
  63.         {Menu -n other {
  64.         {bufferOtherWindow}
  65.         {iconify}
  66.         {nextWin}
  67.         {nextWindow}
  68.         {prevWindow}
  69.         {shrinkFull}
  70.         {shrinkHigh}
  71.         {shrinkLeft}
  72.         {shrinkLow}
  73.         {shrinkRight}
  74.         {singlePage}
  75.         {swapWithNext}
  76.         {zoom}
  77.         }}}
  78.     }
  79.     "(-"
  80.     "/msplitWindow"
  81.     "/otoggleScrollbar"
  82.     "(-"
  83.     }
  84.     # We may be reloading, so add whatever windows we have
  85.     if {[info exists winNameToNum]} {
  86.     set nms [array names winNameToNum]
  87.     foreach name $nms {
  88.         set item [file tail $name]
  89.         set num $winNameToNum($name)
  90.         if {$num < 10}     {
  91.         lappend ma /$num${item}
  92.         } else {
  93.         lappend ma ${item}
  94.         }
  95.     }
  96.     }
  97.     return [list "build" $ma menu::winProc "" $winMenu]
  98. }
  99.  
  100. proc global::listAllBindings {} {
  101.     new -n {* All Key Bindings *} -m Tcl
  102.     insertText [bindingList]
  103.     winReadOnly
  104. }
  105.  
  106. proc global::listGlobalBindings {} {
  107.     global mode::features
  108.     new -n {* Global Key Bindings *} -m Tcl
  109.     set text ""
  110.     set tmp [lsort -ignore [array names mode::features]]
  111.     foreach b [split [bindingList] "\r"] {
  112.     set lst [lindex [split $b  " "] end]
  113.     if {[lsearch $tmp $lst] < 0} {
  114.         append text "$b\r"
  115.     }
  116.     }
  117.     insertText $text
  118.     winReadOnly
  119. }
  120.  
  121. proc global::listPackages {} {
  122.     global index::feature
  123.     cache::read index::maintainer
  124.     foreach i [array names index::maintainer] {
  125.     set j [lindex [set index::maintainer($i)] 1]
  126.     set au($i) "[lindex $j 0], [lindex $j 1]"
  127.     }
  128.     new -n {* Installed Packages *} -m Text
  129.     append t "Currently installed packages\r\r"
  130.     append t "columns are: name, version, and maintainer\r"
  131.     append t "\r\rMenus:"
  132.     insertText $t ; set t ""
  133.     foreach p [lsort -ignore [array names index::feature]] {
  134.     set v [alpha::package versions $p]
  135.     if {[lindex $v 0] == "mode"} {
  136.         set v "for [lindex $v 1] mode"
  137.     }
  138.     switch -- [lindex [set index::feature($p)] 2] {
  139.         "1" {
  140.         append tm "\r[format {  %-25s %-10s  } $p $v]"
  141.         if {[info exists au($p)]} {append tm $au($p)}
  142.         }
  143.         "0" {
  144.         append tp "\r[format {%s %-25s %-10s  } [package::active $p {• { }}] $p $v]"
  145.         if {[info exists au($p)]} {append tp $au($p)}
  146.         }
  147.         "-1" {
  148.         append ta "\r[format {  %-25s %-10s  } $p $v]"
  149.         if {[info exists au($p)]} {append ta $au($p)}
  150.         }
  151.     }
  152.     }
  153.     if {[info exists tm]} {insertText $tm ; unset tm}
  154.     insertText "\r\rFeatures ('•' = active):"
  155.     if {[info exists tp]} {insertText $tp ; unset tp}
  156.     insertText "\r\rAuto-loading features:"
  157.     if {[info exists ta]} {insertText $ta ; unset ta}
  158.     append t "\r\rModes:"
  159.     insertText $t ; set t ""
  160.     foreach p [lsort -ignore [alpha::package names -mode]] {
  161.     set v [alpha::package versions $p]
  162.     if {[lindex $v 0] == "mode"} {
  163.         set v "for [lindex $v 1] mode"
  164.     }
  165.     append t "\r[format {  %-8s %-10s  } $p $v]"
  166.     if {[info exists au($p)]} {append t $au($p)}
  167.     }
  168.     insertText $t ; set t ""
  169.     winReadOnly
  170.     shrinkWindow
  171. }
  172.  
  173. proc global::listFunctions {} {
  174.     global win::Modes
  175.     new -n {* Functions *} -m Tcl
  176.     insertText "===\r\tCommand-double-click on a function to see its definition\r===\r\r" [join [lsort -ignore [info commands]] "\r"] "\r"
  177.     winReadOnly
  178. }
  179.  
  180. proc global::menusAndFeatures {} {
  181.     global global::features mode::features mode
  182.     
  183.     set newGlobals [dialog::pickMenusAndFeatures global]
  184.     set offon [package::onOrOff $newGlobals $mode 1]
  185.  
  186.     set global::features $newGlobals
  187.     # remove removed menus
  188.     foreach m [lindex $offon 0] {
  189.     package::deactivate $m
  190.     }
  191.     foreach m [lindex $offon 1] {
  192.     package::activate $m
  193.     }
  194. }
  195.  
  196. proc global::insertAllMenus {} {
  197.     global global::features index::feature
  198. #    foreach m ${global::features} {
  199. #    if {[lindex [set index::feature($m)] 2] == 0} {
  200. #        package::activate $m
  201. #    }
  202. #    }
  203.     foreach m ${global::features} {
  204.     if {[lindex [set index::feature($m)] 2] == 1} {
  205.         package::activate $m
  206.     }
  207.     }
  208. }
  209.  
  210. proc global::rebuildPackageIndices {} {
  211.     if {[dialog::yesno "You must quit Alpha immediately after rebuilding. \
  212.       Proceed?"]} {
  213.     alpha::rebuildPackageIndices
  214.     }
  215. }
  216.  
  217. ## 
  218.  # -------------------------------------------------------------------------
  219.  # 
  220.  # "menu::buildProc" --
  221.  # 
  222.  #  Register a procedure to be the 'build proc' for a given menu.  This
  223.  #  procedure can do one of two things:
  224.  #  
  225.  #  i) build the entire menu, including evaluating the 'menu ...' command.
  226.  #  In this case the build proc should return anything which doesn't
  227.  #  begin 'build ...'
  228.  #  
  229.  #  ii) build up part of the menu, and then allow pre-registered menu
  230.  #  insertions/replacements to take-effect.  In this case the procedure
  231.  #  should return a list of the items (listed by index):
  232.  #  
  233.  #  0: "build"
  234.  #  1: list-of-items-in-the-menu
  235.  #  2: list of other flags.  If the list doesn't contain '-p', we use
  236.  #  the standard menu::generalProc procedure.  If it does contain '-p'
  237.  #  general prmenu procedure to call when an item is selected.  
  238.  #  If nothing is given,
  239.  #  or if '-1' is given, then we don't have a procedure.  If "" is given,
  240.  #  we use the standard 'menu::generalProc' procedure.  Else we use the
  241.  #  given procedure.
  242.  #  3: list of submenus which need building.
  243.  #  4: over-ride for the name of the menu.
  244.  #  
  245.  #  You must register the build-proc before attempting to build the menu.
  246.  #  Once registered, any call of 'menu::buildSome name' will build your
  247.  #  menu.
  248.  # -------------------------------------------------------------------------
  249.  ##
  250. proc menu::buildProc {name proc} {
  251.     global menu::build_procs
  252.     set menu::build_procs($name) $proc
  253. }
  254.  
  255. ## 
  256.  # -------------------------------------------------------------------------
  257.  # 
  258.  # "menu::insert" --
  259.  # 
  260.  #  name, type, where, then list of items.  type = 'items' 'submenu'
  261.  #  
  262.  #  Add given items to a given menu, provided they are not already there.
  263.  #  Rebuild that menu if necessary.
  264.  #  
  265.  #  There are also procs 'menu::removeFrom' which does the opposite of
  266.  #  this one, and 'menu::replaceWith' which replaces a given menu item
  267.  #  with others.
  268.  # -------------------------------------------------------------------------
  269.  ##
  270. proc menu::insert {name args} {
  271.     if {[llength $args] < 3} { error "Too few args to menu::insert" }
  272.     global menu::additions alpha::noMenusYet
  273.     if {[info exists menu::additions($name)]} {
  274.     set a [set menu::additions($name)]
  275.     if {[lsearch -exact $a $args] != -1} { 
  276.         return 
  277.     }
  278.     # check if it's there but in a different place; we over-ride
  279.     set dblchk [lreplace $args 1 1 "*"]
  280.     if {[set i [lsearch -glob $a $dblchk]] == -1} {
  281.         unset i
  282.     }
  283.     }
  284.     if {[info exists i]} {
  285.     set menu::additions($name) [lreplace $a $i $i $args]
  286.     } else {
  287.     lappend menu::additions($name) $args
  288.     }
  289.     if {![info exists alpha::noMenusYet]} {
  290.     # we were called after start-up; build the menu now
  291.     menu::buildSome $name
  292.     }
  293. }
  294.  
  295. proc menu::uninsert {name args} {
  296.     global menu::additions alpha::noMenusYet
  297.     set a [set menu::additions($name)]
  298.     if {[set idx [lsearch -exact $a $args]] == -1} { 
  299.     return 
  300.     }
  301.     set menu::additions($name) [lreplace $a $idx $idx]
  302.     if {![info exists alpha::noMenusYet]} {
  303.     # we were called after start-up; build the menu now
  304.     menu::buildSome $name
  305.     }
  306. }
  307.  
  308. proc alpha::buildMainMenus {} {
  309.     menu::buildProc packages package::makeMenu
  310.     menu::buildProc packagePrefs menu::packagePrefsBuild
  311.     menu::buildProc mode menu::modeBuild
  312.     menu::buildProc winMenu menu::buildwinMenu
  313.     menu::buildProc preferences menu::preferencesBuild
  314.     uplevel #0 {
  315.     source [file join $HOME Tcl SystemCode alphaMenus.tcl]
  316.     menu::buildSome "File" "Edit" "Text" "Search" "Utils" "Config" "winMenu"
  317.     }
  318. }
  319.  
  320. ## 
  321.  # -------------------------------------------------------------------------
  322.  # 
  323.  # "menu::buildSome" --
  324.  # 
  325.  #  Important procedure which builds all known/registered menus from a
  326.  #  number of pieces.  It allows the inclusion of menus pieces registered
  327.  #  with the menu::insert procedure, which allows you easily to add items
  328.  #  (including dynamic and hierarchial) to any of Alpha's menus.
  329.  # 
  330.  # Results:
  331.  #  Various menus are (re)built
  332.  # 
  333.  # Side effects:
  334.  #  Items added to those menus with 'addMenuItem' will vanish.
  335.  # 
  336.  # --Version--Author------------------Changes-------------------------------
  337.  #    1.0     <darley@fas.harvard.edu> original
  338.  #    2.0     <darley@fas.harvard.edu> more compact, more like tk
  339.  # -------------------------------------------------------------------------
  340.  ##
  341. proc menu::buildSome {args} {
  342.     set msubs {}
  343.     foreach token $args {
  344.     eval lappend msubs [menu::buildOne $token]
  345.     }
  346.     # build sub-menus of those built
  347.     if {[llength $msubs]} {eval menu::buildSome $msubs}
  348. }
  349.  
  350. proc menu::buildOne {args} {
  351.     global menu::additions menu::build_procs alpha::noMenusYet \
  352.       menu::items
  353.     set token [lindex $args 0] ; set args [lrange $args 1 end]
  354.     if {[set len [llength $args]] > 0 || [info exists menu::build_procs($token)]} {
  355.     if {$len > 0} {
  356.         set res $args
  357.     } else {
  358.         if {[catch "[set menu::build_procs($token)]" res]} {
  359.         alpha::reportError "The menu $token had a problem starting up ; $res"
  360.         }
  361.     }
  362.     switch -- [lindex $res 0] {
  363.         "build" {
  364.         set ma [lindex $res 1]
  365.         if {[llength $res] > 2} {
  366.             set theotherflags [lrange [lindex $res 2] 1 end]
  367.             if {[lindex [lindex $res 2] 0] != -1} {
  368.             set mproc [lindex [lindex $res 2] 0]
  369.             }
  370.             if {[lindex $res 3] != ""} {
  371.             eval lappend msubs [lindex $res 3]
  372.             }
  373.             if {[lindex $res 4] != ""} { set name [lindex $res 4] }
  374.         }
  375.         } "menu" - "Menu" {
  376.         eval $res
  377.         return ""
  378.         } default {
  379.         return ""
  380.         }
  381.     }
  382.     } else {
  383.     set ma ""
  384.     if {[info exists menu::items($token)]} {
  385.         set ma [set menu::items($token)]
  386.         global menu::proc menu::which_subs menu::otherflags
  387.         if {[info exists menu::proc($token)]} {
  388.         set mproc [set menu::proc($token)]
  389.         }
  390.         if {[info exists menu::which_subs($token)]} {
  391.         eval lappend msubs [set menu::which_subs($token)]
  392.         }
  393.         if {[info exists menu::otherflags($token)]} {
  394.         set theotherflags [set menu::otherflags($token)]
  395.         }
  396.     }
  397.     }
  398.  
  399.     if {![info exists name]} { set name $token }
  400.     # add any registered items and make the menu contents
  401.     if {[info exists menu::additions($token)]} {
  402.     foreach ins [set menu::additions($token)] {
  403.         set where [lindex $ins 1]
  404.         set type [lindex $ins 0]
  405.         set ins [lrange $ins 2 end]
  406.         switch -- $type {
  407.         "submenu" {
  408.             lappend msubs [lindex $ins 0]
  409.             set ins [list [list Menu -n [lindex $ins 0] {}]]
  410.         }
  411.         }
  412.         switch -- [lindex $where 0] {
  413.         "replace" {
  414.             set old [lindex $where 1]
  415.             if {[set ix [eval llindex ma $old]] != -1} {
  416.             set ma [eval [list lreplace $ma $ix [expr {$ix -1 + [llength $old]}]] $ins]
  417.             } else {
  418.             alertnote "Bad menu::replacement registered '$old'"
  419.             }
  420.             
  421.         }
  422.         "end" {
  423.             eval lappend ma $ins
  424.         }
  425.         default {
  426.             set ma [eval linsert [list $ma] $where $ins]
  427.         }
  428.         }
  429.     }
  430.     }
  431.     # These two lines removed due to some conflicts
  432.     #    regsub -all {"?\(-"?([ \t\r\n]+"?\(-"?)+} $ma "(-" ma
  433.     #    regsub -all {(^[ \t\r\n]*"?\(-"?|"?\(-"?[ \t\r\n]*$)} $ma "" ma
  434.  
  435.     # backwards compatibility fix.  Removed because it's inefficient,
  436.     # and it's about time people used the new Menu command ;-)
  437.     # regsub -all "\{menu " $ma "\{Menu " ma
  438.  
  439.     # build the menu
  440.     set name [list -n $name]
  441.     if {[info exists theotherflags]} {
  442.     set name [concat $theotherflags $name]
  443.     }
  444.     if {[info tclversion] >= 8.0} {
  445.     lappend name -h [list "This is the [lindex $name end] menu"]
  446.     }
  447.     if {[info exists mproc]} {
  448.     if {$mproc != ""} {
  449.         eval Menu $name -p $mproc [list $ma]
  450.     } else {
  451.         eval Menu $name [list $ma]
  452.     }
  453.     } else {
  454.     eval Menu $name -p menu::generalProc [list $ma]
  455.     }
  456.     if {[info exists msubs]} {
  457.     return $msubs
  458.     }
  459.     return ""
  460. }
  461.  
  462. proc menu::replaceRebuild {name title} {
  463.     global $name
  464.     catch {removeMenu [set $name]}
  465.     set $name $title
  466.     menu::buildSome $name
  467.     insertMenu [set $name]
  468. }
  469.  
  470. proc menu::packagePrefsBuild {} {
  471.     global alpha::package_menus package::prefs
  472.     if {[info exists package::prefs]} {
  473.     foreach pkg ${package::prefs} {
  474.         lappend ma "${pkg}Prefs…"
  475.     }
  476.     }
  477.     lappend ma "(-" "describeAPackage…" "readHelpForAPackage…" \
  478.       "uninstallAPackage…" \
  479.       {Menu -m -n internetUpdates -p package::menuProc {}} \
  480.       "(-" "rebuildPackageIndices"
  481.     return [list build $ma menu::packagePrefsProc ]
  482. }
  483.  
  484. proc menu::packagePrefsProc {menu item} {
  485.     global package::prefs
  486.     if {[regexp "(.*)Prefs" $item d pkg]} {
  487.     if {[lcontains package::prefs $pkg]} {
  488.         dialog::pkg_options $pkg
  489.         return
  490.     }
  491.     }
  492.     switch -- $item {
  493.     "describeAPackage" -
  494.     "Describe A Package" {
  495.         set pkg [dialog::optionMenu "Describe which package?" \
  496.           [lsort -ignore [alpha::package names]]]
  497.         package::describe $pkg
  498.     }
  499.     "readHelpForAPackage" -
  500.     "Read Help For A Package" {
  501.         set pkg [dialog::optionMenu "Read help for which package?" \
  502.           [lsort -ignore [alpha::package names]]]
  503.         package::helpFile $pkg
  504.     }
  505.     "uninstallAPackage" -
  506.     "Uninstall A Package" {
  507.         package::uninstall
  508.     }
  509.     "rebuildPackageIndex" {
  510.         alpha::rebuildPackageIndices
  511.     }
  512.     default {
  513.         menu::generalProc global $item
  514.     }
  515.     }
  516. }
  517.  
  518.  
  519. proc menu::menuPackages {menu m} {
  520.     if {[package::helpOrDescribe $m]} {
  521.     return
  522.     }
  523.     # toggle global existence of '$m' menu
  524.     global global::menus modifiedVars
  525.     if {[set idx [lsearch  ${global::menus} $m]] == -1} {
  526.     lappend global::menus $m
  527.     global $m
  528.     catch $m
  529.     insertMenu [set    $m]
  530.     markMenuItem packageMenus $m 1
  531.     } else {
  532.     set global::menus [lreplace ${global::menus} $idx $idx]
  533.     global $m
  534.     catch "removeMenu [set $m]"
  535.     markMenuItem packageMenus $m 0
  536.     }
  537.     lappend modifiedVars global::menus
  538. }
  539.  
  540. if {[info tclversion] < 8.0} {
  541.     proc menu::modeBuild {} {
  542.     set ma [list "/p<BmenusAndFeatures…" "/ppreferences…" "editPrefsFile" \
  543.       "loadPrefsFile…" "describeMode" "(-" "/m<UchangeMode…"]
  544.     return [list build $ma mode::menuProc "" "Mode Prefs"]
  545.     }
  546. } else {
  547.     proc menu::modeBuild {} {
  548.     global mode
  549.     set ma [list "/p<BmenusAndFeatures…" "/ppreferences…" "editPrefsFile" \
  550.       "loadPrefsFile…" "describeMode" "(-" "/m<UchangeMode…"]
  551.     if {$mode != ""} {
  552.         return [list build $ma mode::menuProc "" "${mode} Mode Prefs"]
  553.     } else {
  554.         return [list build $ma mode::menuProc "" "Mode Prefs"]
  555.     }
  556.     }
  557. }
  558.  
  559. proc menu::preferencesBuild {} {
  560.     global flagPrefs
  561.     
  562.     set ma [list "/p<U<BMenus And Features…" "/p<USuffix Mappings…" \
  563.       "Edit Prefs File" "(-" [menu::itemWithIcon "Interface Preferences" 84]]
  564.     lappend ma Tiling Window Wrapping Gui "(-" \
  565.       [menu::itemWithIcon "Standard Preferences" 84]
  566.     lappend ma Backups Electrics Miscellaneous Printer Tags WWW "(-" \
  567.       [menu::itemWithIcon "Other Preferences" 84]
  568.     eval lunion ma [lsort [array names flagPrefs]]
  569.     return [list build $ma {dialog::preferences -m}]
  570. }
  571.  
  572. proc menu::removeFrom {name args} {
  573.     global menu::additions alpha::noMenusYet
  574.     if {[info exists menu::additions($name)]} {
  575.     if {[set i [lsearch -exact [set menu::additions($name)] $args]] != -1} {
  576.         set menu::additions($name) [lreplace [set menu::additions($name)] $i $i]
  577.         if {![info exists alpha::noMenusYet]} {
  578.         # we were called after start-up; build the menu now
  579.         menu::buildSome $name
  580.         }
  581.     }
  582.     }
  583. }
  584.  
  585. proc menu::replaceWith {name current type args} {
  586.     global menu::additions alpha::noMenusYet
  587.     if {![info exists menu::additions($name)]} {
  588.     lappend menu::additions($name) [concat [list $type [list replace $current]] $args]
  589.     } else {
  590.     set add 1
  591.     set j 0
  592.     foreach i [set menu::additions($name)] {
  593.         if {[lrange $i 0 1] == [list $type [list replace $current]]} {
  594.         if {[lindex $i 1] != $args} {
  595.             set add 0
  596.             set menu::additions($name) \
  597.               [lreplace [set menu::additions($name)] $j $j \
  598.               [concat [list $type [list replace $current]] $args]]
  599.             break
  600.         } else {
  601.             # no change
  602.             return
  603.         }
  604.         }
  605.         incr j
  606.     }
  607.     if {$add} {
  608.         lappend menu::additions($name) [concat [list $type [list replace $current]] $args]
  609.     }
  610.     }
  611.     if {![info exists alpha::noMenusYet]} {
  612.     # we were called after start-up; build the menu now
  613.     menu::buildSome $name
  614.     }
  615. }
  616.  
  617. proc menu::itemWithIcon {name icon} {
  618.     return "/\x1e${name}^[text::Ascii $icon 1]"
  619. }
  620.  
  621. proc file::open {} {findFile}
  622. proc file::close {} {killWindow}
  623.  
  624.  
  625. ## 
  626.  # -------------------------------------------------------------------------
  627.  # 
  628.  # "menu::generalProc" --
  629.  # 
  630.  #  If either 'item' or 'menu::item' exists, call it.  Else try and
  631.  #  autoload 'item', if that fails try and autoload 'menu::item'
  632.  # -------------------------------------------------------------------------
  633.  ##
  634. if {[info tclversion] < 8.0} {
  635.     proc menu::generalProc {menu item} {
  636.     set menu [string tolower $menu]
  637.     if {[info commands ${menu}::${item}] != ""} {
  638.         uplevel \#0 ${menu}::$item
  639.     } elseif {[info commands $item] != ""} {
  640.         uplevel \#0 $item
  641.     } elseif {[auto_load ${menu}::$item]} {
  642.         uplevel \#0 ${menu}::$item
  643.     } else {
  644.         uplevel \#0 $item
  645.     }
  646.     }
  647. } else {
  648.     proc menu::generalProc {menu item} {
  649.     set menu [string tolower $menu]
  650.     if {[info commands ::${menu}::${item}] != ""} {
  651.         uplevel \#0 ::${menu}::$item
  652.     } elseif {[info commands $item] != ""} {
  653.         uplevel \#0 $item
  654.     } elseif {[auto_load ::${menu}::$item]} {
  655.         uplevel \#0 ::${menu}::$item
  656.     } else {
  657.         uplevel \#0 $item
  658.     }
  659.     }
  660. }
  661.  
  662. proc menu::globalProc {menu item} {
  663.     menu::generalProc global $item
  664. }
  665.  
  666. proc menu::winProc {menu name} {
  667.     global winNameToNum
  668.  
  669.     set nms [array names winNameToNum]
  670.  
  671.     if {[lsearch $nms "*[quote::Find $name]"] < 0} {
  672.         $name
  673.         return
  674.     }
  675.  
  676.     foreach nm $nms {
  677.         if {[string match *[quote::Find $name] $nm] == "1"}  {
  678.             bringToFront $name
  679.             if {[icon -q]} { icon -f $name -o }
  680.             return
  681.         }
  682.     }
  683.     return "normal"
  684. }
  685.  
  686.  
  687. ## 
  688.  # proc namedClipMenuProc {menu item} {
  689.  #     switch $item {
  690.  #         "copy"      "copyNamedClipboard"
  691.  #         "cut"       "cutNamedClipboard"
  692.  #         "paste"     "pasteNamedClipboard"
  693.  #     }
  694.  # }
  695.  ##
  696.  
  697. proc menu::colorProc {menu item} {
  698.     global colorInds modifiedArrVars
  699.     if {[info exists colorInds($item)]} {
  700.     set color [eval [list colorTriple "New \"$item\":"] $colorInds($item)]
  701.     } else {
  702.     switch -- $item {
  703.         foreground    { set inds "0 0 0" }
  704.         background    { set inds "65535 65535 65535" }
  705.         blue        { set inds "0 0 65535" }
  706.         cyan        { set inds "61404 11464 34250" }
  707.         green        { set inds "1151 33551 8297" }
  708.         magenta        { set inds "44790 1591 51333" }
  709.         red            { set inds "65535 0 0" }
  710.         white        { set inds "65535 65535 65535" }
  711.         yellow        { set inds "61834 64156 12512" }
  712.         default        { set inds "65535 65535 65535" }
  713.     }
  714.     set color [eval [list colorTriple "New \"$item\":"] $inds]
  715.     }
  716.     eval setRGB $item $color
  717.     
  718.     set colorInds($item) $color
  719.     alpha::makeColourList
  720.     lappend modifiedArrVars colorInds
  721. }
  722.  
  723. proc alpha::makeColourList {} {
  724.     global alpha::colors colorInds alpha::basiccolors
  725.     # Set up color indices
  726.     foreach ind [array names colorInds] {
  727.     eval setRGB $ind $colorInds($ind)
  728.     }
  729.     set alpha::basiccolors {none blue cyan green magenta red white yellow}
  730.     set alpha::colors ${alpha::basiccolors}
  731.     foreach c {color_9 color_10 color_11 color_12 color_13 color_14 color_15} {
  732.     if {[info exists colorInds($c)]} {lappend alpha::colors $c}
  733.     }
  734. }
  735.  
  736.  
  737.         
  738. #===============================================================================
  739. proc helpMenu {item} {
  740.     global HOME
  741.     edit -r -c [file join $HOME Help $item]
  742. }
  743.  
  744. ## 
  745.  # -------------------------------------------------------------------------
  746.  # 
  747.  # "alphaHelp" --
  748.  # 
  749.  #  Called from about box
  750.  # -------------------------------------------------------------------------
  751.  ##
  752. proc alphaHelp {} {
  753.     global HOME
  754.     if {[file exists [set f [file join ${HOME} Help "Alpha Manual"]]]} {
  755.     edit -r -c $f
  756.     } else {
  757.     edit -r -c [file join $HOME Help "Quick Start"]
  758.     }
  759. }
  760.  
  761. proc register {} {
  762.     global HOME
  763.     launch -f [file join $HOME Register]
  764. }
  765.  
  766. namespace eval icon {}
  767. namespace eval file {}
  768.  
  769. proc icon::FromSig {sig} {
  770.     global alpha::_icons
  771.     if {[set p [lsearch -glob ${alpha::_icons} "${sig} *"]] != -1} {
  772.     set p [lindex ${alpha::_icons} $p]
  773.     return [lindex $p 2]
  774.     } else {
  775.     return ""
  776.     }
  777. }
  778.  
  779. proc icon::MenuFromSig {sig} {
  780.     global alpha::_icons
  781.     if {[set p [lsearch -glob ${alpha::_icons} "${sig} *"]] != -1} {
  782.     set char [expr {[lindex [lindex ${alpha::_icons} $p] 2] -208}]
  783.     if {$char < 1 || $char > 256} { return "" }
  784.     return "^[text::Ascii $char 1]"
  785.     } else {
  786.     return ""
  787.     }
  788. }
  789.  
  790.  
  791. proc menu::fileUtils {menu item} {
  792.     if {[lsearch -exact {"insertPathName" "insertFile" "fileRemove" "fileInfo" "wordCount" "textToAlpha"} $item] != -1} {return [$item]}
  793.     switch -- $menu {
  794.     "moreUtils" {
  795.         file::Utils::$item
  796.     }
  797.     default {
  798.         file::$item
  799.     }
  800.     }
  801. }
  802.  
  803. proc menu::winTileProc {menu item} {
  804.     win$item
  805. }
  806.  
  807. ## 
  808.  # -------------------------------------------------------------------------
  809.  # 
  810.  #    "menu::buildHierarchy" --
  811.  # 
  812.  #      Given a list of folders, 'menu::buildHierarchy' returns a hierarchical 
  813.  #      menu based on the files and subfolders in each of these folders. 
  814.  #      Pathnames are optionally stored in a global array given by the argument 
  815.  #      'filePaths'. The path's index in this array is formed by concatenating 
  816.  #      the submenu name and the filename, allowing the pathname to be 
  817.  #      retrieved by the procedure 'proc' when the menu item is selected.
  818.  # 
  819.  #     The search may be restricted to files with specific extensions, or files 
  820.  #     matching a certain pattern. A search depth may also be given, with three 
  821.  #     levels    of subfolders assumed by default.
  822.  # 
  823.  #     See MacPerl.tcl or latexMenu.tcl for examples.
  824.  # 
  825.  #     (originally written by    Tom Pollard, with modifications    by Vince Darley    
  826.  #     and Tom Scavo)
  827.  # 
  828.  # --Version--Author------------------Changes-------------------------------
  829.  #      1.0      Tom Pollard                    original
  830.  #      2.0      <vince@das.harvard.edu> multiple extensions, optional    paths
  831.  #      2.1      Tom Scavo                        multiple folders
  832.  #      2.2      <vince@das.harvard.edu> pattern matching as well as exts
  833.  #      2.3      <vince@das.harvard.edu> handles unique menu-names and does text only
  834.  #      2.4      <jl@theophys.kth.se>    now also handles patterns like "*.{a,b}"
  835.  # -------------------------------------------------------------------------
  836.  ##
  837. proc menu::buildHierarchy {folders name proc {filePaths {}} {exts *} {depth 3} {fset {}}} {
  838.     global filesetmodeVars file::separator
  839.     if { $filePaths != "" } {
  840.     global $filePaths
  841.     }
  842.     if {[llength $exts] > 1} {
  843.     regsub -all {\.} $exts "" exts
  844.     set exts "*.{[join $exts ,]}"
  845.     } elseif {[string match ".*" $exts] && ![string match {*\**} $exts]} {set exts "*$exts"}
  846.     incr depth -1
  847.     set overallMenu {}
  848.     foreach folder $folders {
  849.     if {[file exists $folder]} {
  850.         if {![file isdirectory $folder]} {
  851.         set folder "[file dirname $folder]${file::separator}"
  852.         }
  853.         if {![regexp "${file::separator}$" $folder]} {
  854.         set folder "$folder${file::separator}"
  855.         }
  856.         if {$name == 0} {
  857.         set name [file tail [file dirname ${folder}dummy]]
  858.         }
  859.         # if it's a fileset, we register _before_ recursing
  860.         if { $fset != "" } {
  861.         set mname [registerFilesetMenuName $fset $name $proc]
  862.         } else {
  863.         set mname $name
  864.         }
  865.         set menu {}
  866.         set subfolders [glob -nocomplain ${folder}*${file::separator}]
  867.         if {$filesetmodeVars(includeNonTextFiles)} {
  868.         set filenames [glob -nocomplain ${folder}$exts]
  869.         } else {
  870.         set filenames [glob -t TEXT -nocomplain ${folder}$exts]
  871.         }
  872.         # Note that the list of filenames may also contain some/all
  873.         # subfolders (if they matched the glob expression), hence
  874.         # we must be sure not to add them twice.
  875.         foreach m [lsort -ignore [concat $subfolders $filenames]] {
  876.         if {[set s [lsearch -exact $subfolders $m]] != -1 && $depth > 0} {
  877.             set subM [menu::buildHierarchy [list ${m}] 0 $proc $filePaths $exts $depth $fset]
  878.             if {[llength $subM]} { lappend menu $subM }
  879.         } elseif {[file isfile $m]} {
  880.             lappend menu [set fname [file tail $m]]
  881.             if { $filePaths != "" } {
  882.             set ${filePaths}([file join $name $fname]) $m
  883.             }
  884.         }
  885.         }
  886.         
  887.         if {[llength $menu]} {
  888.         set overallMenu [concat $overallMenu $menu]
  889.         }
  890.     } else {
  891.         beep
  892.         alertnote "menu::buildHierarchy:  Folder $folder does not exist!"
  893.     }
  894.     }
  895.     
  896.     if {[llength $overallMenu]} {
  897.     if { [string length $proc] > 1 } {
  898.         set pproc "-p $proc"
  899.     } else {
  900.         set pproc ""
  901.     }    
  902.     if { $fset != "" } {
  903.         if { [string length $proc] > 1 } { set pproc "-p subMenuProc" }
  904.     }     
  905.     return [concat {Menu -m -n} [list $mname] $pproc [list $overallMenu]]
  906.     
  907.     } else {
  908.     return ""
  909.     }
  910. }
  911.  
  912. # in case we've done something odd elsewhere
  913. ensureset filesetmodeVars(includeNonTextFiles) 0
  914.  
  915.  
  916. proc menu::reinterpretOldMenu {args} {
  917.     set ma [lindex $args end]
  918.     set args [lreplace $args end end]
  919.     getOpts {-n -M -p}
  920.     if {[info exists opts(-p)]} {
  921.     lappend proc $opts(-p)
  922.     } else {
  923.     lappend proc "-1"
  924.     }
  925.     if {[info exists opts(-M)]} { lappend proc -M $opts(-m) }
  926.     if {[info exists opts(-m)]} { lappend proc -m }
  927.     menu::buildOne $opts(-n) build $ma $proc
  928. }
  929.  
  930.  
  931.  
  932.  
  933.